home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / basic.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-10-06  |  5.8 KB  |  260 lines
  1. /* ******************************************************************** */
  2. /*  basic.c          Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /* Basic functions                                            */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * Change Log:
  9.  *   Version 1, April 1989
  10.  *      Add many functions - JPff
  11.  *      Add rplaca & rplacd - RJB
  12.  *      Add defmacro - JPff
  13.  *      Introduce GC protection in places - JPff
  14.  *    Wrote NREVERSE for fun - JPff
  15.  *    and ASSOC - JPff
  16.  *    Moved basic.c to generic.c - JPff
  17.  *    Add defconstant and mutability in bindings - JPff
  18.  *      Hacked car & cons on the nil case and fixed the consp 
  19.  *         make_module_function so that it didn't refer to cons !! - (25/10/89) KJP
  20.  *      Altered defun so that its body is a list of forms - (25/10/89) KJP
  21.  */
  22.  
  23.  
  24. #include "defs.h"
  25. #include "structs.h"
  26. #include "funcalls.h"
  27.  
  28. #include "error.h"
  29. #include "global.h"
  30.  
  31. #include "modboot.h"
  32. #include "specials.h"
  33.  
  34. EUFUN_1( Fn_atom, form)
  35. {
  36.   return (is_cons(form) ? nil : lisptrue);
  37. }
  38. EUFUN_CLOSE
  39.  
  40. void printoblist(LispObject *stacktop)
  41. {     /* Broke */
  42.   LispObject ob = (LispObject) ObList;
  43.   while (ob!=NULL) {
  44.     EUCALL_2(Fn_print,ob, StdErr);
  45.     ob = (LispObject) (ob->SYMBOL).left;
  46.   }
  47. }
  48.  
  49. EUFUN_0 (Fn_oblist)
  50. {
  51.   printoblist(stacktop);
  52.   return nil;
  53. }
  54. EUFUN_CLOSE
  55.  
  56. EUFUN_1( Fn_consn, n)
  57. {
  58.   int i;
  59.   LispObject l = nil;
  60.  
  61.   for (i = intval(n); i > 0; --i) {
  62.     ARG_1(stacktop) = l;
  63.     ARG_0(stacktop) = nil;
  64.     l = Fn_cons(stacktop);
  65.   }
  66.  
  67.   return(l);
  68. }
  69. EUFUN_CLOSE
  70.  
  71. EUFUN_1( Fn_system, str)
  72. {
  73.   extern int system(char *);
  74.  
  75.   if (!is_string(str))
  76.     CallError(stacktop,"system: not a string",str,NONCONTINUABLE);
  77.  
  78.   (void) system(stringof(str));
  79.  
  80.   return(nil);
  81. }
  82. EUFUN_CLOSE
  83.  
  84. EUFUN_1( Fn_getenv, str)
  85. {
  86.   extern char *getenv(char *);
  87.   extern int strlen(char *);
  88.   char *value;
  89.  
  90.   if (!is_string(str))
  91.     CallError(stacktop,"getenv: not a string",str,NONCONTINUABLE);
  92.  
  93.   value = getenv(stringof(str));
  94.  
  95.   if (value == NULL) return(nil);
  96.  
  97.   return((LispObject) allocate_string(stacktop,value,strlen(value)));
  98. }
  99. EUFUN_CLOSE
  100.  
  101. EUFUN_0( Fn_exit)
  102. {
  103.   fprintf(StdOut->STREAM.handle,"\n\nExiting EuLisp\n\n");
  104.   
  105.   exit(0);
  106.  
  107.   return(nil);
  108. }
  109. EUFUN_CLOSE
  110.  
  111. EUFUN_0( Fn_make_map)
  112. {
  113.   extern void make_map(void);
  114.  
  115.   make_map();
  116.  
  117.   return(nil);
  118. }
  119. EUFUN_CLOSE
  120.  
  121. /* Time... */
  122.  
  123. #include <sys/types.h>
  124.  
  125. EUFUN_0( Fn_system_time)
  126. {
  127.   extern long time(long *);
  128.   long n;
  129.  
  130.   (void) time(&n);
  131.   return(allocate_integer(stackbase, (int) n));
  132. }
  133. EUFUN_CLOSE
  134.  
  135. EUFUN_0( Fn_process_id)
  136. {
  137.   extern int getpid(void);
  138.  
  139.   return(allocate_integer(stackbase, getpid()));
  140. }
  141. EUFUN_CLOSE
  142.  
  143. EUFUN_0( Fn_backtrace)
  144. {
  145.   extern void module_eval_backtrace(void);
  146.   module_eval_backtrace();
  147.   return(nil);
  148. }
  149. EUFUN_CLOSE
  150.  
  151. EUFUN_0( Fn_cpu_time)
  152. {
  153.   extern long clock(void);
  154.  
  155.   return(allocate_integer(stackbase, (int)(clock()/10000)));
  156. }
  157. EUFUN_CLOSE
  158.  
  159. EUFUN_0( Fn_rand)
  160. {
  161.   extern int rand(void);
  162.  
  163.   return(allocate_integer(stackbase, rand()));
  164. }
  165. EUFUN_CLOSE
  166.  
  167. EUFUN_1( Fn_srand, s)
  168. {
  169.   extern void srand(unsigned int);
  170.  
  171.   srand((unsigned int) intval(s));
  172.  
  173.   return(nil);
  174. }
  175. EUFUN_CLOSE
  176.  
  177. EUFUN_1( Fn_system_describe, obj)
  178. {
  179.   printf("Address: %x\n",(int) obj);
  180.   printf("Type: %x\n",typeof(obj));
  181.   printf("GC: %x\n",gcof(obj));
  182.   printf("Class: %x\n",(int) classof(obj));
  183.   fflush(stdout);
  184.   return(nil);
  185. }
  186. EUFUN_CLOSE
  187.  
  188. /* Weak pointers... */
  189.  
  190. extern LispObject allocate_weak_wrapper(LispObject*, LispObject);
  191.  
  192. EUFUN_1( Fn_make_weak_wrapper, obj)
  193. {
  194.   return(allocate_weak_wrapper(stackbase, obj));
  195. }
  196. EUFUN_CLOSE
  197.  
  198. EUFUN_1( Fn_weak_wrapper_ref, w)
  199. {
  200.   if (!is_weak_wrapper(w))
  201.     CallError(stacktop,
  202.           "weak-wrapper-ref: not a weak wrapper",w,NONCONTINUABLE);
  203.  
  204.   return(w->WEAK_WRAPPER.object);
  205. }
  206. EUFUN_CLOSE
  207.  
  208. EUFUN_2 (Fn_weak_wrapper_ref_setter, w, obj)
  209. {
  210.   if (!is_weak_wrapper(w))
  211.     CallError(stacktop,"(setter weak-wrapper-ref): not a weak wrapper",
  212.           w,NONCONTINUABLE);  
  213.  
  214.   w->WEAK_WRAPPER.object = obj;
  215.  
  216.   return(obj);
  217. }
  218. EUFUN_CLOSE
  219.  
  220. /* *************************************************************** */
  221. /* Initialisation of this section                                  */
  222. /* *************************************************************** */
  223.  
  224. void initialise_basic(LispObject *stacktop)
  225. {
  226.   LispObject get,set;
  227.   
  228.   (void) make_module_function(stacktop,"special-operator-p",Fn_special_form_p,1);
  229.   get = make_module_function(stacktop,"symbol-dynamic-value",Fn_dynamic,1);
  230.   STACK_TMP(get);
  231.   set = make_unexported_module_function(stacktop,"symbol-dynamic-value-updator",
  232.                     Fn_dynamic_setq,2);
  233.   UNSTACK_TMP(get);
  234.   set_anon_associate(stacktop,get,set);
  235.  
  236.   (void) make_module_function(stacktop,"atom",Fn_atom,1);
  237.   (void) make_module_function(stacktop,"oblist", Fn_oblist, 0);
  238.   (void) make_module_function(stacktop,"consn", Fn_consn, 1);
  239.   (void) make_module_function(stacktop,"system",Fn_system,1);
  240.   (void) make_module_function(stacktop,"getenv",Fn_getenv,1);
  241.   (void) make_module_function(stacktop,"exit",Fn_exit,0);
  242.   (void) make_module_function(stacktop,"make-map",Fn_make_map,0);
  243.   (void) make_module_function(stacktop,"system-time",Fn_system_time,0);
  244.   (void) make_module_function(stacktop,"process-id",Fn_process_id,0);
  245.   (void) make_module_function(stacktop,"backtrace",Fn_backtrace,0);
  246.   (void) make_module_function(stacktop,"cpu-time",Fn_cpu_time,0);
  247.   (void) make_module_function(stacktop,"c-rand",Fn_rand,0);
  248.   (void) make_module_function(stacktop,"c-srand",Fn_srand,1);
  249.  
  250.   (void) make_module_function(stacktop,"system-print",Fn_system_describe,1);
  251.  
  252.   (void) make_module_function(stacktop,"make-weak-wrapper",Fn_make_weak_wrapper,1);
  253.   get = make_module_function(stacktop,"weak-wrapper-ref",Fn_weak_wrapper_ref,1);
  254.   STACK_TMP(get);
  255.   set = make_module_function(stacktop,"(setter weak-wrapper-ref)",
  256.                  Fn_weak_wrapper_ref_setter,2);
  257.   UNSTACK_TMP(get);
  258.   set_anon_associate(stacktop,get,set);
  259. }
  260.